Enigma Amiga Life 109/EnigmaAmiga109CD.iso/dalla rivista/amiga.free/sorgenti vari/wolfedit2 2.0.4 source.sit/WolfEdit2 2.0.4 Source/WolfArt ƒ/WolfArt.p

Text File | 1995-03-16 | 4KB | 219 lines

program WolfArt;
    uses
        QDOffscreen;

    const

        firstWallID = 300;
        blankCTableID = 128;
        artCTableID = 129;
        artMapBrgrID = 145;

    type

        RGB8Ptr = ^RGB8;
        RGB8 = packed record
                red, green, blue: 0..255;
            end;

        CMap = packed array[0..767] of 0..255;
        CMapPtr = ^CMap;
        CMapHandle = ^CMapPtr;

    var

        appResFile: integer;
        resFile: integer;
        gworld: GWorldPtr;
        pixmap: PixMapHandle;
        pixels: Ptr;
        drawing: GrafPtr;

    procedure OpenWolf;
        var
            types: SFTypeList;
            reply: StandardFileReply;
            result: OSErr;
    begin
        types[0] := 'APPL';
        while true do begin
                StandardGetFile(nil, 1, types, reply);
                if not reply.sfGood then
                    ExitToShell;
                resFile := FSpOpenResFile(reply.sfFile, fsRdPerm);
                result := ResError;
                if result = noErr then
                    leave;
                writeln('Error number ', result : 1);
            end;
    end;

    procedure SaveCTable (ctab: CTabHandle);
        var
            h: Handle;
            f: integer;
            result: OSErr;
    begin
        h := Handle(ctab);
        result := HandToHand(h);
        f := CurResFile;
        UseResFile(appResFile);
        AddResource(h, 'clut', artCTableID, 'Art Colour Map');
        WriteResource(h);
        UpdateResFile(appResFile);
        UseResFile(f);
    end;

    function GetArtClut: CTabHandle;
        var
            ctab: CTabHandle;
            brgr: CMapHandle;
            i: integer;

        function DoubleByte (x: integer): integer;
        begin
            DoubleByte := BSL(x, 8) + x;
        end;

        procedure RGB8to16 (src: univ RGB8Ptr; var dst: RGBColor);
        begin
            dst.red := DoubleByte(src^.red);
            dst.green := DoubleByte(src^.green);
            dst.blue := DoubleByte(src^.blue);
        end;

    begin
        ctab := GetCTable(artCTableID);
        if ctab = nil then begin
                ctab := GetCTable(blankCTableID);
                brgr := CMapHandle(GetResource('BRGR', artMapBrgrID));
                for i := 0 to 255 do
                    RGB8to16(@brgr^^[3 * i], ctab^^.ctTable[i].rgb);
                SaveCTable(ctab);
            end;
        ctab^^.ctSeed := GetCTSeed;
        GetArtClut := ctab;
    end;

    procedure InitBuffer;
        var
            bounds: Rect;
            ctab: CTabHandle;

        procedure Check (result: QDErr);
        begin
            if result <> noErr then begin
                    writeln('Couldn''t create gworld ( error number ', result : 1, ' ) ');
                    ExitToShell;
                end;
        end;

    begin
        SetRect(bounds, 0, 0, 128, 128);
        ctab := GetArtClut;
        Check(NewGWorld(gworld, 8, bounds, ctab, nil, []));
        pixmap := GetGWorldPixMap(gworld);
        pixmap^^.rowBytes := pixmap^^.rowBytes - 4;
        if not LockPixels(pixmap) then
            writeln('LockPixels returned false!');
        pixels := GetPixBaseAddr(pixmap);
    end;

    procedure ShowBuffer;
        var
            r: Rect;
    begin
        ShowDrawing;
        SetRect(r, 0, 0, 128, 128);
        CopyBits(BitMapPtr(pixmap^)^, thePort^.portBits, r, r, srcCopy, nil);
    end;

{$D-}
    procedure DLZSS (src, dst: univ longint; dstLen: longint);
        type
            PackedByte = packed array[0..0] of 0..255;
            BytePtr = ^PackedByte;
        var
            flagCount: integer;
            flags: integer;
            item: integer;
            copyCount: integer;
            pos: longint;

        function GetByte (var p: longint): integer;
        begin
            GetByte := BytePtr(p)^[0];
            p := p + 1;
        end;

        procedure PutByte (x: longint);
        begin
            BytePtr(dst)^[0] := x;
            dst := dst + 1;
            dstLen := dstLen - 1;
        end;

    begin {DLZSS}
        flagCount := 0;
        while dstLen > 0 do begin
                if flagCount = 0 then begin
                        flags := GetByte(src);
                        flagCount := 8;
                    end;
                if odd(flags) then
                    PutByte(GetByte(src))
                else begin
                        item := GetByte(src);
                        item := item + BSL(GetByte(src), 8);
                        copyCount := 3 + BAND($F, BSR(item, 12));
                        pos := dst - $1000 + BAND(item, $FFF);
                        if copyCount > dstLen then
                            copyCount := dstLen;
                        while copyCount > 0 do begin
                                PutByte(GetByte(pos));
                                copyCount := copyCount - 1;
                            end;
                    end;
                flags := BSR(flags, 1);
                flagCount := flagCount - 1;
            end;
    end;
{$D+}

    procedure ViewWall (id: integer);
        var
            rsrc: Handle;
    begin
        rsrc := GetResource('BRGR', id);
        if rsrc = nil then
            writeln('Wall not found')
        else begin
                DLZSS(rsrc^, pixels, $4000);
                ShowBuffer;
            end;
    end;

    procedure ArtViewLoop;
        var
            n: integer;
            line: string;
    begin
        while true do begin
                write('View wall number: ');
                readln(line);
                if line = '' then
                    ExitToShell;
                readstring(line, n);
                ViewWall(firstWallID + n - 1);
            end;
    end;

begin
    appResFile := CurResFile;
    ShowText;
    ShowDrawing;
    drawing := thePort;
    OpenWolf;
    InitBuffer;
    ArtViewLoop;
end.